home *** CD-ROM | disk | FTP | other *** search
/ IRIX 6.4 Applications 1997 August / SGI IRIX 6.4 Applications 1997 August.iso / dist / imgtools.idb / usr / sgitcl / lib / system.imgtclrc.z / system.imgtclrc
Encoding:
Text File  |  1997-02-07  |  15.4 KB  |  567 lines
  1. #
  2. # system.imgtclrc -- initialization for imgtcl module.
  3. #
  4.  
  5. #
  6. # Execute the autogenerated stuff and the manually generated stuff...
  7. #
  8. if {[info exists env(IMGTCL_VERBOSE)]} {
  9.     puts -nonewline stderr "dlopening imgtcl.so..."
  10. }
  11. dlopen libimgtcl.so init imgtcl_init
  12. if {[info exists env(IMGTCL_VERBOSE)]} {
  13.     puts stderr "done."
  14. }
  15.  
  16. # ---------------------------------------------------------------------------
  17.  
  18. # comment (not perfect; e.g. it evaluates bracketed expressions in comments
  19. proc // {args} {}
  20. proc XXX {args} {puts "XXX $args"}
  21.  
  22. // this sucks...
  23. // switch {5} {
  24.     3 {puts "three"}
  25.     2 {puts "two"}
  26.     $five {puts "FIVE"}
  27.     default {puts "the default"}
  28. }
  29.  
  30. # ----------------------------------------------------------------------------
  31. # System constants...
  32. # ----------------------------------------------------------------------------
  33.  
  34. # "const" is like "set" but it makes the variable read-only,
  35. # and adds it to the list of consts.
  36. proc const {name value} {
  37.     global $name
  38.     set $name $value
  39.     trace variable $name w attempted_write_to_const
  40.     global consts
  41.     lappend consts $name
  42. }
  43. proc attempted_write_to_const {name element operation} {
  44.     if {$element != ""} {
  45.     set name ${name}($element)
  46.     }
  47.     error "it's a constant, you dummy."
  48. }
  49.  
  50. const NULL 0
  51.     # XXX umm... uhh... how to distinguish between NULL and an empty string?
  52. const HZ   100
  53.     # XXX don't hard-code in here!
  54.  
  55. const 0 0; # for things like $[rImg.getResampType]
  56.  
  57.  
  58.  
  59. # ----------------------------------------------------------------------------
  60. # IL Constants...
  61. # ----------------------------------------------------------------------------
  62.  
  63. const FALSE 0
  64. const TRUE 1
  65.  
  66. proc unimplemented {name} {
  67.     global ilOKAY
  68.     proc $name {args} "
  69.     puts {$name not implemented yet...}
  70.     return $ilOKAY
  71.     "
  72. }
  73.  
  74. proc unimplemented_object {classname objname} {
  75.     global ilOKAY
  76.     proc $objname {methodname args} "
  77.     puts \"invoked object $objname's method $classname::\$methodname which is not implemented yet...\"
  78.     return $ilOKAY
  79.     "
  80. }
  81.  
  82. proc unimplemented_class {classname} {
  83.     proc $classname {objname args} "
  84.     puts \"created object \$objname of class $classname which is not implemented yet...\"
  85.     unimplemented_object $classname \$objname
  86.     return \$objname
  87.     "
  88. }
  89. proc unimplemented_ptrclass {classname} {
  90.     proc $classname {objname args} "
  91.     return \$objname
  92.     "
  93. }
  94.  
  95. # -----------------------------------------------------------------------------
  96. # IL Stubs...
  97. # -----------------------------------------------------------------------------
  98.  
  99. unimplemented_ptrclass ilView*
  100. // XXX should put a trace on pointer variables to make sure they get the right type!
  101. unimplemented_ptrclass ilImage*
  102. unimplemented_ptrclass ilImage**
  103. unimplemented_ptrclass ilFileImg*
  104. unimplemented_ptrclass ilFileImg**
  105.  
  106. if {0} {
  107. # hack to define and use a few structs... I'm not sure what we'll use
  108. # eventually...
  109. proc iflXYint {objname args} {
  110.     global $objname
  111.     set ${objname}(x) 0
  112.     set ${objname}(y) 0
  113. }
  114. proc iflXYSint {objname args} {
  115.     global $objname
  116.     set ${objname}(x) 0
  117.     set ${objname}(y) 0
  118. }
  119.  
  120. proc iflXYSint_array {name init_list} {
  121.     upvar $name A
  122.     set n [llength $init_list]
  123.     for {set i 0} {$i < $n} {incr i} {
  124.     set A($i,x) [lindex [lindex $init_list $i] 0]
  125.     set A($i,y) [lindex [lindex $init_list $i] 1]
  126.     }
  127. }
  128. proc iflXYSfloat_array {name init_list} {
  129.     upvar $name A
  130.     for {set i 0} {$i < 3} {incr i} {
  131.     set A($i,x) [lindex [lindex init_list $i] 0]
  132.     set A($i,y) [lindex [lindex init_list $i] 1]
  133.     }
  134. }
  135.  
  136. proc short {name} {
  137.     # do nothing
  138. }
  139. proc int {name} {
  140.     # do nothing
  141. }
  142.  
  143. }
  144.  
  145. proc getdescription {name} {
  146.     global description
  147.     if {[info exists description($name)]} {
  148.     return $description($name)
  149.     } else {
  150.     return $name
  151.     }
  152. }
  153.  
  154. // Support obj.method syntax...
  155. // I have misgivings about this, since it is a performance drain every time
  156. // any method command is executed.
  157. // XXX idea: the first time foo.bar is executed, it could
  158. // actually create a command called foo.bar;
  159. // then subsequent calls wouldn't need to go through this "unknown" mechanism.
  160. // But then these would need to be deleted when the object is deleted,
  161. // which would be a bloody mess to keep track of...
  162.  
  163. rename unknown _unknown_pre_il
  164. proc unknown {name args} {
  165.  
  166.     #
  167.     # If $name is of the form obj.method, call $obj $method.
  168.     #
  169.     if {[scan $name {%[^.].%s} obj method] == 2} {
  170.     return [uplevel $obj $method $args]
  171.     }
  172.  
  173.     #
  174.     # If $name is of the form ptr->method, call $$ptr $method.
  175.     #
  176.     if {[scan $name {%[^-]->%s} ptr method] == 2} {
  177.     return [uplevel [uplevel set $ptr] $method $args]
  178.     }
  179.  
  180.     #
  181.     # If $name is of the form (classname*)addr, call $classname:: $addr.
  182.     #
  183.     if {[scan $name {(%[_a-zA-Z0-9]*)%s} classname addr] == 2} {
  184.     return [uplevel $classname:: $addr $args]
  185.     }
  186.  
  187.     #
  188.     # If $name is of the form (struct_or_scalar_name {dims})addr,
  189.     # call $struct_or_scalarname:: $dims $addr
  190.     #
  191.     if {[scan $name {(%[_a-zA-Z0-9] {%[^\}]})%s} structname dims addr] == 3} {
  192.     return [va_uplevel _array_command $structname $dims $addr $args]
  193.     }
  194.  
  195.     #
  196.     # Call the default "unknown".
  197.     # The following would do it:
  198.     #     return [uplevel _unknown_pre_il $name $args]
  199.     # except that we want to discard the stack trace from this point down.
  200.     # So instead we catch the error (if there is one)
  201.     # and pass it up with an empty stack trace.
  202.     #
  203.     set code [catch {uplevel _unknown_pre_il $name $args} result]
  204.     return -code $code $result
  205. }
  206.  
  207.  
  208. # Wanted to call this "array", but tcl already has
  209. # such a command...
  210. proc new {type name {dims ""} {equals ""} {initlist ""}} {
  211.     global sizeof
  212.     if {! [regexp {^[_a-zA-Z]} $name]} {
  213.     # no name supplied-- shift args accordingly
  214.     set initlist $equals
  215.     set equals $dims
  216.     set dims $name
  217.     set name ""
  218.     }
  219.     if {$dims == ""} {
  220.     return -code 1 "dims not specified properly"
  221.     }
  222.  
  223.     # XXX here, check whether a variable or procedure
  224.     # of this name exists, and if so, reject.
  225.     # (Then won't need the "write" trace below, only the "unset" trace.
  226.  
  227.     if { [regexp {\*$} $type] } {
  228.     set sizeoftype $sizeof(void*)
  229.     } else {
  230.     set sizeoftype $sizeof($type)
  231.     }
  232.  
  233.     if {$equals == "addr" && [string range $initlist 0 2] != "0x"} {
  234.     # memory is being passed to us, don't allocate any, just use it
  235.     set equals ""
  236.     set addr $initlist
  237.     set initlist ""
  238.     set ownMemory 0
  239.     } else {
  240.     set addr [malloc [expr $sizeoftype * [join $dims *]]]
  241.     if {! $addr} {
  242.         return -code 1 "malloc([expr $sizeoftype * [join $dims *]]) failed"
  243.     }
  244.     set ownMemory 1
  245.     }
  246.     set result "($type {$dims})$addr"
  247.  
  248.     if {$addr != 0} {
  249.     if {$equals != "" || $initlist != ""} {
  250.         if {$equals != "=" || $initlist == ""} {
  251.         free $addr
  252.         return -code 1 "invalid initializer \"$equals $initlist\""
  253.         }
  254.         if {[catch {$result = $initlist} error_result] == 1} {
  255.         free $addr
  256.         return -code 1 $error_result
  257.         }
  258.     }
  259.     }
  260.  
  261.     if {$name != ""} {
  262.     #
  263.     # Set the named variable to the string containing
  264.     # the address and indexing info...
  265.     # Note that this will trigger cleaning up of any
  266.     # previous value of the variable and command,
  267.     # so it must be done before we define the command.
  268.     #
  269.     uplevel [list set $name $result]
  270.  
  271.     #
  272.     # Create a command called name...
  273.     # This doesn't accomplish much in the current implementation,
  274.     # but if the "new" command is rewritten in C,
  275.     # it could allocate a struct describing the array and strides
  276.     # and use this as the client data,
  277.     # so that they wouldn't need to be recalculated every dang
  278.     # time the array is derefed.
  279.     #
  280.  
  281.     set hidden_name [_localproc_uniquename]
  282.     if {[info commands $name] != {}} {
  283.         rename $name $hidden_name
  284.     }
  285.     proc $name {args} "
  286.         va_call _array_command $type \{$dims\} $addr \$args
  287.     "
  288.  
  289.     # set the trace on the variable to free the space and delete the command
  290.     # unless this was an "addr" style initialization in which case we don't
  291.     # own the memory
  292.     if ($ownMemory) {
  293.         uplevel [list trace variable $name wu \
  294.             "array_unset_or_reset_callback \"$result\" $hidden_name"]
  295.     }
  296.     }
  297.  
  298.     return $result
  299. }
  300.  
  301. #
  302. # Calling a function and passing it the trailing varargs "args" arguments
  303. # seems to be extremely awkward in tcl; here is a function that does it.
  304. # Takes any number of arguments; the first one should be a command name, and
  305. # the last one should be an "args" list that will get expanded
  306. # and passed to the command along with the preceding arguments.
  307. #
  308. proc va_call {args} {
  309.     set nargs [llength $args]
  310.     set lastargs [lindex $args [expr $nargs - 1]]
  311.     set firstargs [lrange $args 0 [expr $nargs - 2]]
  312.     eval [concat $firstargs $lastargs]
  313. }
  314. proc va_uplevel {args} {
  315.     # Note, does not understand the "level" argument of uplevel
  316.     set nargs [llength $args]
  317.     set lastargs [lindex $args [expr $nargs - 1]]
  318.     set firstargs [lrange $args 0 [expr $nargs - 2]]
  319.     uplevel [concat $firstargs $lastargs]
  320. }
  321.  
  322. #XXX
  323. proc printvar {name} {
  324.     upvar $name value
  325.     puts "$name = \"$value\""
  326. }
  327.  
  328. proc _array_command {type dims addr args} {
  329.     # Suppose A is "(iflSize {2 3})0x123456".
  330.     # Then "A 0" or "A {0} should return "(iflSize {3})0x12345".
  331.     # "A + 1" should return "(iflSize {1 3})0x12345a"
  332.     # "A 0 0" or "A {0 0}" should return "{512 512 1 3}"
  333.     # "A 0 0 x" or "A {0 0} x" should return "512"
  334.     # "A 0 0 x = 20" or "A {0 0} x = 20" should set A[0][0].x = 20
  335.     global sizeof
  336.  
  337.     #printvar type
  338.     #printvar dims
  339.     #printvar addr
  340.     #printvar args
  341.  
  342.     #
  343.     # Set inds equal to the concatenation of all the
  344.     # initial args that look like numbers or lists of numbers.
  345.     #
  346.  
  347.     set inds ""
  348.     while {[regexp {^[0-9]} [set firstarg [lindex $args 0]]]} {
  349.     set inds [concat $inds $firstarg]
  350.     set args [lreplace $args 0 0]
  351.     }
  352.  
  353.     #printvar inds
  354.     #printvar args
  355.     #puts ""
  356.  
  357.     set ndims [llength $dims]
  358.     set ninds [llength $inds]
  359.  
  360.     if {$ninds > $ndims} {
  361.     error "Too many indices $inds for ($type {$dims})$addr"
  362.     }
  363.  
  364.     if { [regexp {\*$} $type] } {
  365.     set mangledtype "void_ptr_"
  366.     set sizeoftype $sizeof(void*)
  367.     } else {
  368.     set mangledtype $type
  369.     set sizeoftype $sizeof($type)
  370.     }
  371.  
  372.     #
  373.     # Peel off a dimension and an index, until there are no more indices...
  374.     #
  375.     while {$ninds > 0} {
  376.     set dim0 [lindex $dims 0]
  377.     set ind0 [lindex $inds 0]
  378.  
  379.     if {$ind0 < 0 || $ind0 >= $dim0} {
  380.         error "Index \"$ind0\" out of bounds \"$dim0\" for ($type {$dims})$addr"
  381.     }
  382.  
  383.     set addr [expr $addr + $ind0 * $sizeoftype * [join $dims *] / $dim0]
  384.     set addr [format %#x $addr]    ;# XXX possible performance drain here
  385.     set dims [lrange $dims 1 end]
  386.     set inds [lrange $inds 1 end]
  387.     incr ndims -1
  388.     incr ninds -1
  389.     }
  390.  
  391.     if {$ndims > 0} {
  392.     if {$args == {}} {
  393.         # This is the syntax for returning the array as a list
  394.         set args "="
  395.     }
  396.     if {[lindex $args 0] == "="} {
  397.         switch [llength $args] {
  398.         1 {
  399.             #
  400.             # Return the entire C array as a list
  401.             #
  402.             set result {}
  403.             set dim0 [lindex $dims 0]
  404.             for {set i 0} {$i < $dim0} {incr i} {
  405.             lappend result [_array_command $type $dims $addr $i =]
  406.             }
  407.             return $result
  408.         }
  409.         2 {
  410.             #
  411.             # Set the C array from the explicit list given
  412.             #
  413.             set initlist [lindex $args 1]
  414.             set ninits [llength $initlist]
  415.             if {$ninits > [lindex $dims 0]} {
  416.             error "Initializer list $initlist too long for ($type {$dims})$addr"
  417.             }
  418.             for {set i 0} {$i < $ninits} {incr i} {
  419.             _array_command $type $dims $addr $i = [lindex $initlist $i]
  420.             }
  421.             return ""
  422.         }
  423.         default {
  424.             puts [llength $args]
  425.             error "Bad initializer \"$args\" for ($type {$dims})$addr"
  426.         }
  427.         }
  428.     } elseif {[lindex $args 0] == "+"} {
  429.         if {[llength $args] != 1} {
  430.         ....
  431.         XXX
  432.         }
  433.     } else {
  434.         error "Unrecognized argument syntax \"$args\" for ($type {$dims})$addr"
  435.  
  436.     }
  437.     }
  438.  
  439.     # At this point, $ndims and $ninds are both 0
  440.  
  441.     if {$args == "="} {
  442.     return [$mangledtype:: $addr]
  443.     } else {
  444.     return [va_call $mangledtype:: $addr $args]
  445.     }
  446. }
  447.  
  448. proc array_unset_or_reset_callback {old_value hidden_name name element op} {
  449.     # XXX The following may be a performance drain...
  450.     global env
  451.     if {[info exists env(IMGTCL_UNSET_VERBOSE)]} {
  452.     puts stderr "In array unset cb, name=$name, elt=$element, op=$op, old value=$old_value"
  453.     }
  454.  
  455.     free $old_value
  456.     rename $name ""
  457.     if {[info commands $hidden_name] != {}} {
  458.     rename $hidden_name $name
  459.     }
  460.     uplevel [list trace vdelete $name wu \
  461.         "array_unset_or_reset_callback \"$old_value\" $hidden_name"]
  462. }
  463.  
  464. #
  465. # "localproc" is like "proc" but it
  466. # creates a procedure that is local to the current stack frame;
  467. # i.e. it gets destroyed and the previous implementation (if any)
  468. # is restored when the current stack frame is destroyed.
  469. #
  470. # This is complicated due to ugliness in the unset-trace implementation.
  471. # For example, to implement a local procedure "foo",
  472. # call
  473. #    localproc foo {...} {
  474. #        ...
  475. #    }
  476. # How this is implemented:
  477. #    chooses a unique name like __localproc_uniquename_2983
  478. #    if there's already a function named foo,
  479. #        then rename it __localproc_uniquename_2983
  480. #    creates the function foo as specified
  481. #
  482. #    set __localproc_uniquename_2983(foo) "arbitrary value"
  483. #    put a trace on __localproc_uniquename_2983(foo)
  484. #        so that when it is unset, we will
  485. #        restore the original procedure foo.
  486. #        (Note:  The reason we encode the procedure name
  487. #        and its "hidden name" in the name of the variable
  488. #        rather than in the contents of the variable
  489. #        is that the contents of the variable
  490. #        are undefined while the unset-trace-callback
  491. #        is being executed (which seems silly to me,
  492. #        but that's the way it is)).
  493. #    set __localproc_hidden_name(foo) __localproc_uniquename_2983
  494. #        (Note:  The reason we also set __localproc_hidden_name(foo)
  495. #        is so that we can implement a procedure "unlocalproc"
  496. #        which will restore the original foo;
  497. #        it needs to be able to look up the hidden name
  498. #        knowing only the name "foo", and it can't do this
  499. #        from only the variable __localproc_uniquename_2983(foo).
  500. # 
  501. #
  502.  
  503. proc localproc {procname args body} {
  504.     if {[uplevel info exists __localproc_hidden_name($procname)]} {
  505.     error "localproc \"$procname\" already exists"
  506.     }
  507.     set hidden_name [_localproc_uniquename]
  508.     if {[info commands $procname] != {}} {
  509.     rename $procname $hidden_name
  510.     }
  511.  
  512.     uplevel [list set __localproc_hidden_name($procname) $hidden_name]
  513.     uplevel [list trace variable __localproc_hidden_name($procname) wu \
  514.          "_localproc_unset_trace $procname $hidden_name"]
  515.  
  516.     uplevel [list proc $procname $args $body]
  517. }
  518.  
  519. proc unlocalproc {procname} {
  520.     # The unset-trace callback is what does the real work...
  521.     uplevel [list unset __localproc_hidden_name($procname)]
  522. }
  523.  
  524. proc _localproc_unset_trace {procname hidden_name    name elt op} {
  525.     rename $procname ""
  526.     if {[info commands $hidden_name] != {}} {
  527.     rename $hidden_name $procname
  528.     }
  529. }
  530.  
  531. set __localproc_uniquename_i 0
  532. proc _localproc_uniquename {} {
  533.     global __localproc_uniquename_i
  534.     return __localproc_uniquename_[incr __localproc_uniquename_i]
  535. }
  536.  
  537. // {
  538.  
  539. # -----------------------------------------------------------------------------
  540. # Experimenting with calling-with-named-args...
  541.  
  542. # The original way... (note that the y=0 default is useless)
  543. proc foo {a b {c 0}} {}
  544. proc bar {x {y 0} z args} {}
  545.  
  546. # Split into the "real" functions and the user-friendly "wrapper" functions...
  547. proc _foo {a b {c 0}} {}
  548. proc _bar {x {y 0} z args} {}
  549.  
  550. proc foo {args} {
  551.     set c 0
  552.     foreach 
  553. }
  554.  
  555.  
  556. }
  557.  
  558. # Set prompt for interactive sessions...
  559. # Do this last; if an error occurred before this point,
  560. # the user will know something is wrong because the prompt is unfamiliar...
  561. set tcl_prompt1 "puts -nonewline \"imgtcl> \""
  562. set tcl_prompt2 "puts -nonewline \"> \""
  563.  
  564. return;    # so return value will be "" and not the result of the previous command
  565.  
  566. }
  567.